home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 11
/
Cream of the Crop 11-1.iso
/
comm
/
ftp4w24b.zip
/
tp7
/
pwftp.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-05-12
|
10KB
|
341 lines
Program PWFTP;
{$A+,B-,D+,F-,G+,I-,K+,L+,N-,P+,Q+,R+,S+,T+,V+,W+,X+,Y+}
Uses WinTypes, WinProcs, WinCrt, Strings, UseFTP4W;
Const TIL = 255;
Type PTextItem = ^TTextItem;
TTextItem = Array [0..TIL] Of Char;
PLongTextItem = ^TLongTextItem;
TLongTextItem = Array [0..$FF00] Of Char;
PWndProc = ^TWndProc;
TWndProc = Function (Receiver: hWnd; MSG, wParam: Word; lParam: LongInt): LongInt;
Var Status, TransferMode: Integer;
T, U: TTextItem;
TerminateProgram, Flag: Boolean;
hWindow: hWnd;
SaveWndProc: TWndProc;
Data: PFtp_ProcData;
Procedure WriteWinsockVerInfo;
Const WSADESCRIPTION_LEN = 256;
WSASYS_STATUS_LEN = 128;
Type TWSAData = Record
wVersion: Word;
wHighVersion: Word;
szDescription: Array [0..WSADESCRIPTION_LEN] Of Char;
szSystemStatus: Array [0..WSASYS_STATUS_LEN] Of Char;
iMaxSockets: Byte;
iMaxUdpDg: Byte;
lpVendorInfo: Pointer;
End;
TWSAStartUp = Function (wVersionRequested: Word; WSAData: TWSAData): Integer;
TWSACleanup = Function: Integer;
Var WSAData: TWSAData;
hWinsock: THandle;
FP : TFarProc;
Begin
hWinsock := LoadLibrary ('WINSOCK');
If hWinsock >= 32 Then
Begin
FP := GetProcAddress (hWinsock, 'WSAStartup');
If FP <> NIL Then
If TWSAStartUp (FP) (257, WSAData) = 0 Then
WriteLn (WSAData.szDescription);
FP := GetProcAddress (hWinsock, 'WSACleanup');
If FP <> NIL Then TWSACleanUp (FP);
FreeLibrary (hWinsock)
End
End;
Function MyWndProc (Receiver: hWnd; MSG, wParam: Word; lParam: LongInt): LongInt; Export;
Var W, L: Word;
Begin
If MSG = wm_User+10 Then {verbose}
Begin
If WhereX <> 1 Then
Begin
WriteLn;
Write (#8); {delete last "*" after get}
End;
L := StrLen (PLongTextItem (lParam)^);
For W := 0 To L Do
If PLongTextItem (lParam)^ [W] <> #13 Then
If PLongTextItem (lParam)^ [W] = #10 Then WriteLn
Else Write (PLongTextItem (lParam)^ [W]);
If L > 0 Then
If PLongTextItem (lParam)^ [L-1] <> #10 Then WriteLn;
End;
If MSG = wm_User+11 Then {dir, ls}
Begin
If wParam = 1 Then
Begin
Status := lParam;
Flag := True
End
Else WriteLn (PChar (lParam));
End;
If MSG = wm_User+12 Then {get, put}
Begin
If wParam = 1 Then
Begin
Status := lParam;
Flag := True
End
Else Write ('*');
End;
If MSG = wm_Char Then
Begin
If wParam = vk_Escape Then
Begin
FtpAbort;
Status := FtpFlush;
End;
If wParam = vk_Cancel Then
Begin
FtpAbort;
WriteLn (#13#10'### Disconnecting ###');
Halt;
End;
End;
MyWndProc := SaveWndProc (Receiver, MSG, wParam, lParam);
End;
Procedure WriteHostType;
Type TPA = Array [0..3] Of PChar;
Var PA: TPA;
Begin
PA [0] := StrNew ('Unix');
PA [1] := StrNew ('VMS');
PA [2] := StrNew ('Dos');
PA [3] := NIL;
Status := FtpSyst (@PA);
If Status < 1000 Then WriteLn ('Detected host type: ', PA [Status]);
StrDispose (PA[0]);
StrDispose (PA[1]);
StrDispose (PA[2]);
End;
Procedure AnalyseLine (Var Line, Command, Params: String);
Var I: Byte;
Begin
I := Pos (' ', Line);
If I = 0 Then
Begin
Command := Line;
Params := '';
Exit
End;
Command := Copy (Line, 1, I-1);
Params := Copy (Line, I+1, TIL);
End;
Procedure DoOpen (Var Line: String);
Var S, H: String;
Begin
AnalyseLine (Line, H, S);
If Length (H) = 0 Then
Begin
Write ('to: ');
ReadLn (H);
If Length (H) = 0 Then Exit;
End;
StrPCopy (T, H);
Status := FTPOpenConnection (T);
If Status <> FTPERR_OK Then Exit;
AnalyseLine (S, H, S);
If Length (H) = 0 Then
Begin
Write ('user: ');
ReadLn (H);
End;
StrPCopy (T, H);
Status := FTPSendUserName (T);
If (Status <> FTPERR_OK) And (Status <> FTPERR_ENTERPASSWORD) Then Exit;
If Length (S) = 0 Then
Begin
Write ('password: ');
ReadLn (S);
End;
StrPCopy (T, S);
Status := FTPSendPasswd (T);
If Status <> FTPERR_OK Then Exit;
WriteLn ('Connected to ', Data^.Ftp.saSockAddr.in_addr.B1,
'.', Data^.Ftp.saSockAddr.in_addr.B2,
'.', Data^.Ftp.saSockAddr.in_addr.B3,
'.', Data^.Ftp.saSockAddr.in_addr.B4);
WriteHostType;
End;
Procedure DoDir (Var Line: String);
Var I: Integer;
Begin
Flag := False;
StrPCopy (T, Line);
Status := FtpDir (T, NIL, TRUE, hWindow, wm_User+11);
If Status <> FTPERR_OK Then Exit;
Repeat Write (#0) Until Flag;
End;
Procedure DoMode (Var Line: String);
Begin
If Length (Line) > 0 Then
Case Upcase (Line [1]) Of
'B' : TransferMode := TYPE_I;
'A' : TransferMode := TYPE_A
Else WriteLn ('?unknown mode');
End;
Case TransferMode Of
TYPE_I : WriteLn ('mode is binary');
TYPE_A : WriteLn ('mode is ascii');
End;
Status := FTPERR_OK;
End;
Procedure DoGet (Var Line: String);
Var H: String;
Begin
Flag := False;
AnalyseLine (Line, H, Line);
StrPCopy (T, H);
If Length (Line) = 0 Then StrCopy (U, T) Else StrPCopy (U, Line);
Status := FtpRecvFile (T, U, TransferMode, TRUE, hWindow, wm_User+12);
If Status = FTPERR_OK Then Repeat Write (#0) Until Flag;
Write (#8);
End;
Procedure DoPut (Var Line: String);
Var H: String;
Begin
Flag := False;
AnalyseLine (Line, H, Line);
StrPCopy (T, H);
If Length (Line) = 0 Then StrCopy (U, T) Else StrPCopy (U, Line);
Status := FtpSendFile (T, U, TransferMode, TRUE, hWindow, wm_User+12);
If Status = FTPERR_Ok Then Repeat Write (#0) Until Flag;
End;
Procedure DoQuote (Var WholeLine: String);
Begin
StrPCopy (T, WholeLine);
Status := FtpQuote (T, NIL, 0);
If Status < 1000 Then Status := FTPERR_OK;
End;
Procedure DoCD (Var Line: String);
Begin
StrPCopy (T, Line);
If Line = '..' Then Status := FtpCDUP
Else If Line <> '' Then Status := FtpCWD (T);
If Status < 1000 Then Status := FtpPWD (NIL, 0)
Else WriteLn (Status);
End;
Procedure DoCDPP (Var Line: String);
Begin
Status := FtpCDUP;
If Status < 1000 Then Status := FtpPWD (NIL, 0)
End;
Procedure DoHelp (Var Line: String);
Begin
StrPCopy (T, Line);
If Length (Line) > 0 Then Status := FtpHelp (T, NIL, 0)
Else Status := FtpQuote ('help', NIL, 0);
End;
Procedure DoLocalHelp (Var Line: String);
Begin
WriteLn ('open [host] [user] [password] open connection to host');
WriteLn ('dir [selection] print directory');
WriteLn ('cd [new dir or ..] change directory');
WriteLn ('mode [binary|ascii] change transfermode');
WriteLn ('get remotefile [localfile] download file');
WriteLn ('put localfile [remotefile] upload file');
WriteLn ('remotehelp [command] get help from host');
WriteLn ('info print info about connections');
WriteLn ('close close connection');
WriteLn ('bye quit FTP client');
WriteLn ('--> arguments in brackets are optional <--');
WriteLn ('ESCAPE cancel transfer');
WriteLn ('CONTROL-C abort program');
Status := FTPERR_Ok;
End;
Procedure DoInfo (Var Line: String);
Var P: PFtp_ProcData;
B: Byte;
Begin
P := Data;
While P^.Prev <> NIL Do P := P^.Prev;
B := 0;
While P <> NIL Do
Begin
Inc (B);
P := P^.Next
End;
WriteLn ('Number of tasks: ', B);
Status := FTPERR_OK;
End;
Procedure DoClose (Var Line: String);
Begin
Status := FTPCloseConnection;
End;
Procedure MainLoop;
Var Line, S, H: String;
Begin
TerminateProgram := False;
Repeat
Status := -10;
Write ('ftp>');
ReadLn (Line);
AnalyseLine (Line, H, S);
If H = '' Then Status := FTPERR_OK;
If H = 'open' Then DoOpen (S);
If H = 'close' Then DoClose (S);
If (H = 'dir') Or (H = 'ls') Then DoDir (S);
If H = 'mode' Then DoMode (S);
If H = 'get' Then DoGet (S);
If H = 'put' Then DoPut (S);
If Line = 'cd..' Then DoCDPP (S);
If H = 'cd' Then DoCD (S);
If H = 'remotehelp' Then DoHelp (S);
If (H = '?') or (H = 'help') Then DoLocalHelp (S);
If H = 'info' Then DoInfo (S);
If H = 'bye' Then
Begin
DoClose (S);
Status := FTPERR_OK;
TerminateProgram := True;
End;
If Status = -10 Then DoQuote (Line);
If Status >= 1000 Then WriteLn ('?', FTP4W_Error (Status));
Until TerminateProgram;
End;
Var FP: TFarProc;
Begin
CheckBreak := False;
CmdShow := sw_showMaximized;
WriteLn ('Simple FTP Client V1.1 by AStA (Andreas.Tikart@uni-konstanz.de) <Polarwolf>');
Ftp4wVer (T, TIL);
WriteLn (T);
WriteWinsockVerInfo;
hWindow := GetFocus;
LongInt (FP) := SetWindowLong (hWindow, GWL_WndProc, LongInt (@MyWndProc));
SaveWndProc := TWndProc (FP);
Status := FTPInit (hWindow);
Data := FtpDataPtr;
FtpSetVerboseMode (Integer (TRUE), hWindow, wm_User+10);
TransferMode := Type_I;
MainLoop;
FtpRelease;
DoneWinCrt;
End.